home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / hoist.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  11.1 KB  |  337 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. structure Hoist : sig val hoist : (string->unit)->CPS.cexp->CPS.cexp end =
  3. struct
  4.  open Access CPS SortedList
  5. structure CG = System.Control.CG
  6.  
  7. type fv = lvar list
  8.  
  9. type rebind = (lvar * lvar) list
  10.  
  11. datatype cexp'
  12.   = RECORD' of record_kind * (value * accesspath) list * lvar * cexp' * fv
  13.   | SELECT' of int * value * lvar * cexp' * fv
  14.   | OFFSET' of int * value * lvar * cexp' * fv
  15.   | APP' of value * value list
  16.   | FIX' of function' list * fv * cexp' * fv
  17.   | SWITCH' of value * lvar * (cexp' * fv) list
  18.   | SETTER' of P.setter * value list * cexp' * fv
  19.   | LOOKER' of P.looker * value list * lvar * cexp' * fv
  20.   | PURE' of P.pure * value list * lvar * cexp' * fv
  21.   | ARITH' of P.arith * value list * lvar * cexp' * fv
  22.   | BRANCH' of P.branch * value list * lvar * cexp' * fv * cexp' * fv
  23. withtype function' = lvar * lvar list * cexp' * fv
  24.  
  25.  fun sum f = let fun h [] = 0 
  26.            | h (a::r) = f a + h r
  27.           in h
  28.          end
  29.  
  30. fun sublist test =
  31.   let fun subl(a::r) = if test a then a::(subl r) else subl r
  32.         | subl [] = []
  33.   in  subl
  34.   end
  35.  
  36. fun split pred =
  37.     let fun f nil = (nil,nil)
  38.           | f (a::r) = let val (x,y) = f r
  39.                 in if pred a then (a::x, y) else (x, a::y)
  40.                    end
  41.         in f
  42.        end
  43.  
  44.  fun escapers cexp =
  45.   let val s = Intset.new()
  46.       val escape' = Intset.add s
  47.       fun escape(VAR x) = escape' x
  48.         | escape _ = ()
  49.       val rec pass1 = 
  50.       fn RECORD(_,vl,w,e) =>  (app (escape o #1) vl; pass1 e)
  51.        | SELECT (i,v,w,e) => pass1 e
  52.        | APP(f,vl) => app escape vl
  53.        | FIX(l, e) => (app (pass1 o #3) l; pass1 e)
  54.        | SWITCH(v,_,el) => app pass1 el
  55.        | LOOKER(_,vl,_,e) => pass1 e
  56.        | ARITH(_,vl,_,e) => pass1 e
  57.        | PURE(_,vl,_,e) => (app escape vl; pass1 e)
  58.        | SETTER(_,vl,e) => (app escape vl; pass1 e)
  59.        | BRANCH(_,_,_,e1,e2) => (pass1 e1; pass1 e2)
  60.        | OFFSET _ => ErrorMsg.impossible "OFFSET in hoist"
  61.   in pass1 cexp; Intset.mem s
  62.  end
  63.  
  64.  local fun vars(l, VAR x :: rest) = vars(x::l, rest)
  65.        | vars(l, _::rest) = vars(l,rest)
  66.        | vars(l, nil) = uniq l
  67.    in fun uniqv l = vars(nil, l)
  68.   end
  69.  
  70.  fun hoist click cexp =
  71.   let (* val _ = CPSprint.show System.Print.say (Intmap.map ctab) cexp *)
  72.       val clicked = ref false
  73.       val click = fn x => (clicked := true; click x)
  74.       infix 6 \/ val op \/ = merge
  75.       infix 7 /\ val op /\ = intersect
  76.       infix 6 -- val op -- = fn(a,b) => remove(b,a)
  77.       val escapes = escapers cexp
  78.       exception Pushdown
  79.       (* the variable x always stands for a function value *)
  80.       fun pushdown(x,x1,e,v0,make) =
  81.         let fun g(v1) = (v1\/x1)--[x]
  82.         val rec push =
  83.         fn RECORD'(k,vl,w,e,v2) =>
  84.              if member (uniqv (map #1 vl)) x then raise Pushdown
  85.              else RECORD'(k,vl,w, push e, g v2)
  86.              | SELECT'(i,v as VAR x',w,e,v2) => if x=x' then raise Pushdown
  87.                              else SELECT'(i,v,w,push e, g v2)
  88.              | SELECT'(i,v,w,e,v2) => SELECT'(i,v,w,push e, g v2)
  89.          | LOOKER'(i,vl,w,e,v2) => 
  90.            if member(uniqv vl) x then raise Pushdown
  91.                else LOOKER'(i,vl,w,push e,g v2)
  92.          | ARITH'(i,vl,w,e,v2) => 
  93.            if member(uniqv vl) x then raise Pushdown
  94.                else ARITH'(i,vl,w,push e,g v2)
  95.          | PURE'(i,vl,w,e,v2) => 
  96.            if member(uniqv vl) x then raise Pushdown
  97.                else PURE'(i,vl,w,push e,g v2)
  98.          | SETTER'(i,vl,e,v2) => 
  99.            if member(uniqv vl) x then raise Pushdown
  100.                else SETTER'(i,vl,push e,g v2)
  101.              | FIX'(l,v1,e,v2) =>
  102.            if member v1 x then raise Pushdown
  103.                else FIX'(l,v1, push e, g v2)
  104.              | e as BRANCH'(i,vl,c,e1,v1,e2,v2) => 
  105.           (if member (uniqv vl) x then raise Pushdown
  106.              else case (member v1 x, member v2 x)
  107.                of (false,false) => e
  108.                 | (true,false) =>
  109.                    let val (e1',v1') = push1(e1,v1)
  110.                     in BRANCH'(i,vl,c,e1', v1', e2,v2)
  111.                    end
  112.                 | (false,true) =>
  113.                    let val (e2',v2') = push1(e2,v2)
  114.                     in BRANCH'(i,vl,c,e1, v1, e2',v2')
  115.                    end
  116.                 | (true,true) => raise Pushdown)
  117.              | _ => raise Pushdown
  118.             and push1 = fn(e1,v1) => 
  119.         (click "%";
  120.          (push e1, g v1) handle Pushdown => (make(e1,v1), g v1))
  121.      in ((push e handle Pushdown => make(e,v0)), g v0)
  122.     end
  123.                
  124.       val rec hoist = 
  125.     fn RECORD(k,vl, w, e) =>
  126.       let fun makerecord(e,v) = pushdown(w,uniqv(map #1 vl),e,v,
  127.                          fn(e,v)=>RECORD'(k,vl,w,e,v))
  128.            in case hoist e
  129.         of ev as (FIX'(l,v1,e2,v2), _) => 
  130.             if member v1 w orelse not(!CG.hoistup)
  131.               then makerecord ev
  132.               else let val (e5,v5) = makerecord(e2,v2)
  133.                 in (FIX'(l,v1,e5,v5), v1\/(v5--uniq(map #1 l)))
  134.                end
  135.         | ev => makerecord ev
  136.           end
  137.      | SELECT(i,v,w,e) =>
  138.        let fun makeselect(e,v0) = pushdown(w,uniqv[v],e,v0,
  139.                           fn(e,v0)=>SELECT'(i,v,w,e,v0))
  140.         in case hoist e of
  141.           ev as (FIX'(l,v1,e2,v2), _) => 
  142.           if member v1 w orelse not(!CG.hoistup)
  143.               then makeselect ev
  144.               else let val (e5,v5) = makeselect(e2,v2)
  145.                 in (FIX'(l,v1,e5,v5),v1\/(v5--uniq(map #1 l)))
  146.                end
  147.         | ev => makeselect ev
  148.        end
  149.          | LOOKER(i,vl,w,e) =>
  150.        let fun makeprim(e,v) = 
  151.                       (LOOKER'(i,vl,w,e,v), v--[w]\/uniqv vl)
  152.         in case hoist e
  153.          of ev as (FIX'(l,v1,e2,v2),_) =>
  154.            (case ([w] /\ v1, !CG.hoistup)
  155.              of ([],true) => let val (e5,v5) = makeprim(e2,v2)
  156.                      in (FIX'(l,v1,e5,v5),v1\/(v5--uniq(map #1 l)))
  157.                     end
  158.              | _  =>  makeprim ev)
  159.           | ev => makeprim ev
  160.         end
  161.          | ARITH(i,vl,w,e) =>
  162.        let fun makeprim(e,v) = 
  163.                       (ARITH'(i,vl,w,e,v), v--[w]\/uniqv vl)
  164.         in case hoist e
  165.          of ev as (FIX'(l,v1,e2,v2),_) =>
  166.            (case ([w] /\ v1, !CG.hoistup)
  167.              of ([],true) => let val (e5,v5) = makeprim(e2,v2)
  168.                      in (FIX'(l,v1,e5,v5),v1\/(v5--uniq(map #1 l)))
  169.                     end
  170.              | _  =>  makeprim ev)
  171.           | ev => makeprim ev
  172.         end
  173.          | PURE(i,vl,w,e) =>
  174.        let fun makeprim(e,v) = 
  175.                 pushdown(w,uniqv vl,e,v,
  176.                  fn (e,v) => PURE'(i,vl,w,e,v))
  177.         in case hoist e
  178.          of ev as (FIX'(l,v1,e2,v2),_) =>
  179.            (case ([w] /\ v1, !CG.hoistup)
  180.              of ([],true) => let val (e5,v5) = makeprim(e2,v2)
  181.                      in (FIX'(l,v1,e5,v5),v1\/(v5--uniq(map #1 l)))
  182.                     end
  183.              | _  =>  makeprim ev)
  184.           | ev => makeprim ev
  185.         end
  186.          | SETTER(i,vl,e) =>
  187.        let fun makeprim(e,v) = 
  188.                       (SETTER'(i,vl,e,v), v \/ uniqv vl)
  189.         in case hoist e
  190.          of ev as (FIX'(l,v1,e2,v2),_) =>
  191.             if !CG.hoistup
  192.              then let val (e5,v5) = makeprim(e2,v2)
  193.                in (FIX'(l,v1,e5,v5),v1\/(v5--uniq(map #1 l)))
  194.               end
  195.              else makeprim ev
  196.           | ev => makeprim ev
  197.         end
  198.            
  199.      | BRANCH(i,vl,c,e1,e2) =>
  200.            let val (e1',v1') = hoist e1
  201.            val (e2',v2') = hoist e2
  202.         in (BRANCH'(i,vl,c,e1',v1',e2',v2'),
  203.             uniqv vl \/ v1' \/ v2')
  204.            end
  205.  
  206.      | APP(f,vl) => (APP'(f,vl), uniqv(f::vl))
  207.      | SWITCH(v,c,el) => 
  208.             let val el' = map hoist el
  209.              in (SWITCH'(v, c, el'), foldmerge(map #2 el')\/uniqv[v])
  210.             end
  211.      | FIX(l,e) =>
  212.        let fun h((f,vl,(e as FIX'(l',v1,e',v2),v3))::r) =
  213.               (case (uniq vl /\ v1, !CG.hoistup)
  214.                 of ([],true) => (click "*"; 
  215.                          (f,vl,e',v2):: l' @ h r)
  216.                  | _ => (f,vl,e,v3) :: h r)
  217.          | h((f,vl,(a,va))::r) = (f,vl,a,va) :: h r
  218.          | h [] = []
  219.            val l = h (map (fn(f,vl,a)=>(f,vl,hoist a)) l)
  220.            fun gather(a,nil,dontadd) = (a,dontadd)
  221.                  | gather(a,add,dontadd) = 
  222.             let val a' = a @ add
  223.                 val va = uniq(map #1 a')
  224.                 fun test(_,_,_,v1) = (v1/\va<>nil)
  225.                 val (add',dontadd') = split test dontadd
  226.              in gather(a',add',dontadd')
  227.             end
  228.            val (esc,nonesc) = split (escapes o #1) l
  229.            val (downbunch,upbunch) = gather(nil,esc,nonesc)
  230.            val downdef = uniq(map #1 downbunch)
  231.            val updef = uniq(map #1 upbunch)
  232.            val vd = foldmerge(map (#4) downbunch) -- downdef
  233.            val vu = foldmerge(map (#4) upbunch) -- updef
  234.            val (e,v2) = hoist e
  235.            exception Down
  236.            fun check vl = if !CG.hoistdown 
  237.                   then case downdef /\ uniqv vl of [] => () 
  238.                             | _ => raise Down
  239.                   else raise Down
  240.            fun present (_,vx) = case downdef/\vx
  241.                       of []=>0 | _ => 1
  242.            val rec down' = fn (cexp,vx) => 
  243.                 case downdef /\ vx
  244.                  of [] => (cexp,vx)
  245.                   | _ => down cexp 
  246.                      handle Down => (FIX'(downbunch,vd,cexp,vx),
  247.                              vx--downdef\/vd)
  248.            and down =
  249.         fn RECORD'(k,vl,w,e,v3) => (check(map #1 vl); 
  250.                 let val (e',v4) = down e
  251.                  in (RECORD'(k,vl,w,e',v4),v4--[w]\/uniqv(map #1 vl))
  252.                 end)
  253.          | SELECT'(i,v,w,e,v3) => 
  254.                 let val (e',v4) = (check nil; down e)
  255.                  in (SELECT'(i,v,w,e',v4), v4--[w]\/uniqv[v])
  256.                 end
  257.          | LOOKER'(i,vl,w,e,_) =>
  258.                (check vl;
  259.             let val (e',v4) = down e
  260.              in (LOOKER'(i,vl,w,e',v4), v4--[w] \/ uniqv vl)
  261.             end)
  262.          | ARITH'(i,vl,w,e,_) =>
  263.                (check vl;
  264.             let val (e',v4) = down e
  265.              in (ARITH'(i,vl,w,e',v4), v4--[w] \/ uniqv vl)
  266.             end)
  267.          | PURE'(i,vl,w,e,_) =>
  268.                (check vl;
  269.             let val (e',v4) = down e
  270.              in (PURE'(i,vl,w,e',v4), v4--[w] \/ uniqv vl)
  271.             end)
  272.          | SETTER'(i,vl,e,_) =>
  273.                (check vl;
  274.             let val (e',v4) = down e
  275.              in (SETTER'(i,vl,e',v4), v4 \/ uniqv vl)
  276.             end)
  277.          | BRANCH'(i,vl,c,e1,v1,e2,v2) =>
  278.              (check vl;
  279.               if present(e1,v1)+present(e2,v2) < 2 
  280.                 then let val (e1',v1') = down'(e1,v1)
  281.                      val (e2',v2') = down'(e2,v2)
  282.                   in click "&";
  283.                      (BRANCH'(i,vl,c,e1',v1',e2',v2'), 
  284.                       v1' \/ v2' \/ uniqv vl)
  285.                  end
  286.                 else raise Down)
  287.          | SWITCH'(v,c,el) => (* can't switch on a function *)
  288.               (check nil;
  289.                if sum present el < 2
  290.               then let val el' = map down' el
  291.                 in (SWITCH'(v,c,el'), 
  292.                     foldmerge(map #2 el')\/uniqv[v])
  293.                    end
  294.               else raise Down)
  295.          | e as APP'(f,vl) => (check(f::vl); click ")"; 
  296.                        (e, uniqv(f::vl)))
  297.          | FIX'(m,v3,e',v4) => 
  298.             (*  (!CG.hoistdown orelse !CG.hoistup) required here *)
  299.             let val v5 = vd\/(v3--downdef)
  300.              in click "_"; 
  301.                 (FIX'(downbunch@m,v5,e',v4),
  302.                  v5\/(v4--(downdef\/uniq(map #1 m))))
  303.             end
  304.         in (case (upbunch, 
  305.                       case downbunch of nil => raise Down | _ => down e)
  306.          of (nil,e_v) => e_v
  307.           | (_,(e',v7)) => (FIX'(upbunch,vu,e',v7),v7--updef\/vu))
  308.            handle Down => let val v1 = (vd\/vu)--(updef\/downdef)
  309.                    in (FIX'(l,v1,e,v2),v1--(updef\/downdef)\/v2)
  310.                   end
  311.        end
  312.       val rec clean =
  313.     fn RECORD'(k,vl,w,e,_) => RECORD(k,vl,w,clean e)
  314.      | SELECT'(i,v,w,e,_) => SELECT(i,v,w, clean e)
  315.      | SETTER'(i,vl,e,_) => SETTER(i,vl,clean e)
  316.      | LOOKER'(i,vl,w,e,_) => LOOKER(i,vl,w,clean e)
  317.      | ARITH'(i,vl,w,e,_) => ARITH(i,vl,w,clean e)
  318.      | PURE'(i,vl,w,e,_) => PURE(i,vl,w,clean e)
  319.      | BRANCH'(i,vl,c,e1,_,e2,_) => BRANCH(i,vl,c,clean e1, clean e2)
  320.          | SWITCH'(v,c,el) => SWITCH(v, c, map (clean o #1) el)
  321.      | APP'(f,vl) => APP(f,vl)
  322.      | FIX'(l,_,e,_) => FIX(map (fn (f,vl,e,_)=>(f,vl,clean e)) l, clean e)
  323.       val cexp' = #1(hoist cexp)
  324.     fun ssss cexp = if !CG.misc1 (*debug*)
  325.             then (System.Print.say "\nAfter hoist: \n"; 
  326.               if !CG.misc4=16 then
  327.                   CPSprint.show System.Print.say cexp
  328.               else ();
  329.               cexp)
  330.                 else cexp
  331.  
  332.  
  333.    in if !clicked then ssss(clean cexp') else cexp
  334.   end
  335.  
  336. end
  337.